home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / hyperbole / hmouse-drv.el < prev    next >
Encoding:
Text File  |  1995-07-08  |  16.2 KB  |  437 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hmouse-drv.el
  4. ;; SUMMARY:      Smart Key/Mouse driver functions.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     hypermedia, mouse
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORIG-DATE:    04-Feb-90
  10. ;; LAST-MOD:      6-Jul-95 at 14:29:54 by Bob Weiner
  11. ;;
  12. ;; This file is part of Hyperbole.
  13. ;; Available for use and distribution under the same terms as GNU Emacs.
  14. ;;
  15. ;; Copyright (C) 1989-1995, Free Software Foundation, Inc.
  16. ;; Developed with support from Motorola Inc.
  17. ;;
  18. ;; DESCRIPTION:  
  19. ;; DESCRIP-END.
  20.  
  21. ;;; ************************************************************************
  22. ;;; Other required Elisp libraries
  23. ;;; ************************************************************************
  24.  
  25. (require 'hypb)
  26.  
  27. ;;; ************************************************************************
  28. ;;; Public variables
  29. ;;; ************************************************************************
  30.  
  31. (defvar action-key-depress-window nil
  32.   "The last window in which the Action Key was depressed or nil.")
  33. (defvar assist-key-depress-window nil
  34.   "The last window in which the Assist Key was depressed or nil.")
  35. (defvar action-key-release-window nil
  36.   "The last window in which the Action Key was released or nil.")
  37. (defvar assist-key-release-window nil
  38.   "The last window in which the Assist Key was released or nil.")
  39.  
  40. (defvar action-key-depress-prev-point nil
  41.   "Marker at point prior to last Action Key depress.
  42. Note that this may be a buffer different than where the depress occurs.")
  43. (defvar assist-key-depress-prev-point nil
  44.   "Marker at point prior to last Assist Key depress.
  45. Note that this may be a buffer different than where the depress occurs.")
  46. (defvar action-key-release-prev-point nil
  47.   "Marker at point prior to last Action Key release.
  48. Note that this may be a buffer different than where the release occurs.")
  49. (defvar assist-key-release-prev-point nil
  50.   "Marker at point prior to last Assist Key release.
  51. Note that this may be a buffer different than where the release occurs.")
  52.  
  53. (defvar action-key-cancelled nil
  54.   "When non-nil, cancels last Action Key depress.")
  55. (defvar assist-key-cancelled nil
  56.   "When non-nil, cancels last Assist Key depress.")
  57.  
  58. (defvar action-key-help-flag nil
  59.   "When non-nil, forces display of help for next Action Key release.")
  60. (defvar assist-key-help-flag nil
  61.   "When non-nil, forces display of help for next Assist Key release.")
  62.  
  63. ;;; ************************************************************************
  64. ;;; Hyperbole context-sensitive key driver functions
  65. ;;; ************************************************************************
  66.  
  67. (defun action-mouse-key (&rest args)
  68.   "Set point to the current mouse cursor position and execute 'action-key'.
  69. Any ARGS will be passed to 'hmouse-function'."
  70.   (interactive)
  71.   (require 'hsite)
  72.   ;; Make this a no-op if some local mouse key binding overrode the global
  73.   ;; action-key-depress command invocation.
  74.   (if action-key-depressed-flag
  75.       (let ((hkey-alist hmouse-alist))
  76.     (setq action-key-depressed-flag nil)
  77.     (cond (action-key-cancelled
  78.         (setq action-key-cancelled nil
  79.               assist-key-depressed-flag nil))
  80.           (assist-key-depressed-flag
  81.         (hmouse-function nil nil args))
  82.           ((action-mouse-key-help nil args))
  83.           (t (hmouse-function 'action-key nil args))))))
  84.  
  85. (defun assist-mouse-key (&rest args)
  86.   "Set point to the current mouse cursor position and execute 'assist-key'.
  87. Any ARGS will be passed to 'hmouse-function'."
  88.   (interactive)
  89.   (require 'hsite)
  90.   ;; Make this a no-op if some local mouse key binding overrode the global
  91.   ;; assist-key-depress command invocation.
  92.   (if assist-key-depressed-flag
  93.       (let ((hkey-alist hmouse-alist))
  94.     (setq assist-key-depressed-flag nil)
  95.     (cond (assist-key-cancelled
  96.         (setq assist-key-cancelled nil
  97.               action-key-depressed-flag nil))
  98.           (action-key-depressed-flag
  99.         (hmouse-function nil t args))
  100.           ((action-mouse-key-help t args))
  101.           (t (hmouse-function 'assist-key t args))))))
  102.  
  103. (defun hmouse-function (func assist-flag set-point-arg-list)
  104.   "Executes FUNC for Action Key (Assist Key with ASSIST-FLAG non-nil) and sets point from SET-POINT-ARG-LIST.
  105. FUNC may be nil in which case no function is called.
  106. SET-POINT-ARG-LIST is passed to the call of the command bound to
  107. 'hmouse-set-point-command'.  Returns nil if 'hmouse-set-point-command' variable
  108. is not bound to a valid function."
  109.   (if (fboundp hmouse-set-point-command)
  110.       (let ((release-args (hmouse-set-point set-point-arg-list)))
  111.     (if assist-flag
  112.         (setq assist-key-release-window (selected-window)
  113.           assist-key-release-args release-args
  114.           assist-key-release-prev-point (point-marker))
  115.       (setq action-key-release-window (selected-window)
  116.         action-key-release-args release-args
  117.         action-key-release-prev-point (point-marker)))
  118.     (and (eq major-mode 'br-mode)
  119.          (setq action-mouse-key-prev-window 
  120.            (if (br-in-view-window-p)
  121.                (save-window-excursion
  122.              (br-next-listing-window)
  123.              (selected-window))
  124.              (selected-window))))
  125.     (setq action-mouse-key-prefix-arg current-prefix-arg)
  126.     (if (null func)
  127.         nil
  128.       (funcall func)
  129.       (setq action-mouse-key-prev-window nil
  130.         action-mouse-key-prefix-arg nil))
  131.     t)))
  132.  
  133. (defun action-mouse-key-help (assist-flag args)
  134.   "If a Smart Key help flag is set and the other Smart Key is not down, shows help.
  135. Takes two args:  ASSIST-FLAG should be non-nil iff command applies to the Assist Key.
  136. ARGS is a list of arguments passed to 'hmouse-function'.
  137. Returns t if help is displayed, nil otherwise."
  138.   (let ((help-shown)
  139.     (other-key-released (not (if assist-flag
  140.                      action-key-depressed-flag
  141.                    assist-key-depressed-flag))))
  142.     (unwind-protect
  143.     (setq help-shown
  144.           (cond ((and  action-key-help-flag other-key-released)
  145.              (setq action-key-help-flag nil)
  146.              (hmouse-function 'hkey-help assist-flag args)
  147.              t)
  148.             ((and  assist-key-help-flag other-key-released)
  149.              (setq assist-key-help-flag nil)
  150.              (hmouse-function 'assist-key-help assist-flag args)
  151.              t)))
  152.       (if help-shown
  153.       ;; Then both Smart Keys have been released. 
  154.       (progn (setq action-key-cancelled nil
  155.                assist-key-cancelled nil)
  156.          t)))))
  157.  
  158. (defun action-key ()
  159.   "Use one key to perform functions that vary by buffer.
  160. Default function is given by 'action-key-default-function' variable.
  161. Returns t unless 'action-key-default-function' variable is not bound to a valid
  162. function."
  163.   (interactive)
  164.   (require 'hsite)
  165.   (or (hkey-execute nil)
  166.       (if (fboundp action-key-default-function)
  167.      (progn (funcall action-key-default-function)
  168.         t))))
  169.  
  170. (defun assist-key ()
  171.   "Use one assist-key to perform functions that vary by buffer.
  172. Default function is given by 'assist-key-default-function' variable.
  173. Returns non-nil unless 'assist-key-default-function' variable is not bound
  174. to a valid function."
  175.   (interactive)
  176.   (require 'hsite)
  177.   (or (hkey-execute t)
  178.       (if (fboundp assist-key-default-function)
  179.       (progn (funcall assist-key-default-function)
  180.          t))))
  181.  
  182. (defun hkey-execute (assist-flag)
  183.   "Evaluate Action Key form (or Assist Key form with ASSIST-FLAG non-nil) for first non-nil predicate from 'hkey-alist'.
  184. Non-nil ASSIST-FLAG means evaluate second form, otherwise evaluate first form.
  185. Returns non-nil iff a non-nil predicate is found."
  186.     (let ((pred-forms hkey-alist)
  187.       (pred-form) (pred-t))
  188.       (while (and (null pred-t) (setq pred-form (car pred-forms)))
  189.     (if (setq pred-t (eval (car pred-form)))
  190.         (eval (if assist-flag (cdr (cdr pred-form)) (car (cdr pred-form))))
  191.       (setq pred-forms (cdr pred-forms))))
  192.       pred-t))
  193.  
  194. (defun hkey-help (&optional assist-flag)
  195.   "Display help for the Action Key command in current context.
  196. With optional ASSIST-FLAG non-nil, display help for the Assist Key command.
  197. Returns non-nil iff associated help documentation is found."
  198.   (interactive "P")
  199.   (require 'hsite)
  200.   (let ((pred-forms hkey-alist)
  201.     (pred-form) (pred-t) (call) (cmd-sym) (doc))
  202.     (while (and (null pred-t) (setq pred-form (car pred-forms)))
  203.       (or (setq pred-t (eval (car pred-form)))
  204.       (setq pred-forms (cdr pred-forms))))
  205.     (if pred-t
  206.     (setq call (if assist-flag (cdr (cdr pred-form))
  207.              (car (cdr pred-form)))
  208.           cmd-sym (car call))
  209.       (setq cmd-sym
  210.         (if assist-flag assist-key-default-function action-key-default-function)
  211.         call cmd-sym))
  212.     (setq hkey-help-msg
  213.       (if (and cmd-sym (symbolp cmd-sym))
  214.           (progn
  215.         (setq doc (documentation cmd-sym))
  216.         (let* ((condition (car pred-form))
  217.                (temp-buffer-show-hook
  218.              (function
  219.                (lambda (buf)
  220.                  (set-buffer buf)
  221.                  (setq buffer-read-only t)
  222.                  (if (br-in-browser)
  223.                  (save-excursion
  224.                    (let ((owind (selected-window)))
  225.                      (br-to-view-window)
  226.                      (select-window (previous-window))
  227.                      (display-buffer buf 'other-win)
  228.                      (select-window owind)))
  229.                    (display-buffer buf 'other-win)))))
  230.                (temp-buffer-show-function temp-buffer-show-hook))
  231.           (with-output-to-temp-buffer (hypb:help-buf-name "Smart")
  232.             (princ (format "A click of the %s Key"
  233.                    (if assist-flag "Assist" "Action")))
  234.             (terpri)
  235.             (princ "WHEN  ")
  236.             (princ
  237.               (or condition
  238.               "there is no matching context"))
  239.             (terpri)
  240.             (princ "CALLS ") (princ call)
  241.             (if doc (progn (princ " WHICH:") (terpri) (terpri)
  242.                    (princ doc)))
  243.             (if (memq cmd-sym '(hui:hbut-act hui:hbut-help))
  244.             (progn
  245.               (princ (format "\n\nBUTTON SPECIFICS:\n\n%s\n"
  246.                      (actype:doc 'hbut:current t)))
  247.               (hattr:report
  248.                 (nthcdr 2 (hattr:list 'hbut:current)))))
  249.             (terpri)
  250.             ))
  251.         "")
  252.         (message "No %s Key command for current context."
  253.              (if assist-flag "Assist" "Action"))))
  254.     doc))
  255.  
  256. (defun assist-key-help ()
  257.   "Display doc associated with Assist Key command in current context.
  258. Returns non-nil iff associated documentation is found."
  259.   (interactive)
  260.   (hkey-help 'assist))
  261.  
  262. (defun hkey-help-hide ()
  263.   "Restores frame to configuration prior to help buffer display.
  264. Point must be in the help buffer."
  265.   (let ((buf (current-buffer)))
  266.     (if *hkey-wconfig*
  267.     (set-window-configuration *hkey-wconfig*)
  268.       (switch-to-buffer (other-buffer)))
  269.     (bury-buffer buf)
  270.     (setq *hkey-wconfig* nil)))
  271.  
  272. (defun hkey-help-show (buffer &optional current-window)
  273.   "Saves prior frame configuration if BUFFER displays help.  Displays BUFFER.
  274.  
  275. Optional second arg CURRENT-WINDOW non-nil forces display of buffer within
  276. the current window.  By default, it is displayed in another window."
  277.   (if (bufferp buffer) (setq buffer (buffer-name buffer)))
  278.   (and (stringp buffer)
  279.        (string-match "Help\\*$" buffer)
  280.        (not (memq t (mapcar (function
  281.                  (lambda (wind)
  282.                    (string-match
  283.                 "Help\\*$"
  284.                 (buffer-name (window-buffer wind)))))
  285.                 (hypb:window-list 'no-mini))))
  286.        (setq *hkey-wconfig* (current-window-configuration)))
  287.   (let* ((buf (get-buffer-create buffer))
  288.      (wind (if current-window
  289.            (progn (switch-to-buffer buf)
  290.               (selected-window))
  291.          (display-buffer buf))))
  292.     (setq minibuffer-scroll-window wind)))
  293.  
  294. (defun hkey-operate (arg)
  295.   "Uses the keyboard to emulate Smart Mouse Key drag actions.
  296. Each invocation alternates between starting a drag and ending it.
  297. Prefix ARG non-nil means emulate Assist Key rather than the Action Key."
  298.   (interactive "P")
  299.   (or hyperb:window-system
  300.       (hypb:error "(hkey-operate): Drag actions require mouse support"))
  301.   (if arg
  302.       (if assist-key-depressed-flag
  303.       (progn (assist-mouse-key)
  304.          (message "Assist Key released."))
  305.     (assist-key-depress)
  306.     (message
  307.       "Assist Key depressed; go to release point and hit {%s %s}."
  308.       (substitute-command-keys "\\[universal-argument]")
  309.       (substitute-command-keys "\\[hkey-operate]")
  310.       ))
  311.     (if action-key-depressed-flag
  312.     (progn (action-mouse-key)
  313.            (message "Action Key released."))
  314.       (action-key-depress)
  315.       (message "Action Key depressed; go to release point and hit {%s}."
  316.            (substitute-command-keys "\\[hkey-operate]"))
  317.       )))
  318.  
  319. (defun hkey-summarize (&optional current-window)
  320.   "Displays smart key operation summary in help buffer.
  321. Optional arg CURRENT-WINDOW non-nil forces display of buffer within
  322. the current window.  By default, it is displayed in another window."
  323.   (let* ((doc-file (hypb:mouse-help-file))
  324.      (buf-name (hypb:help-buf-name "Smart"))
  325.      (wind (get-buffer-window buf-name))
  326.      owind)
  327.     (if (file-readable-p doc-file)
  328.     (progn
  329.       (if (br-in-browser)
  330.           (br-to-view-window))
  331.       (setq owind (selected-window))
  332.       (unwind-protect
  333.           (progn
  334.         (if wind
  335.             (select-window wind)
  336.           (hkey-help-show buf-name current-window)
  337.           (select-window (get-buffer-window buf-name)))
  338.         (setq buffer-read-only nil) (erase-buffer)
  339.         (insert-file-contents doc-file)
  340.         (goto-char (point-min))
  341.         (set-buffer-modified-p nil))
  342.         (select-window owind))))))
  343.  
  344. ;; ************************************************************************
  345. ;; Private variables
  346. ;; ************************************************************************
  347.  
  348. (defvar action-key-depress-args nil
  349.   "List of mouse event args from most recent depress of the Action Key.")
  350. (defvar assist-key-depress-args nil
  351.   "List of mouse event args from most recent depress of the Assist Key.")
  352.  
  353. (defvar action-key-release-args nil
  354.   "List of mouse event args from most recent release of the Action Key.")
  355. (defvar assist-key-release-args nil
  356.   "List of mouse event args from most recent release of the Assist Key.")
  357.  
  358. (defvar action-mouse-key-prev-window nil
  359.   "Window point was in prior to current invocation of 'action/assist-mouse-key'.")
  360.  
  361. (defvar action-mouse-key-prefix-arg nil
  362.   "Prefix argument to pass to 'smart-br-cmd-select'.")
  363.  
  364. (defvar action-key-depressed-flag nil "t while Action Key is depressed.")
  365. (defvar assist-key-depressed-flag nil "t while Assist Key is depressed.")
  366. (defvar hkey-help-msg "" "Holds last Smart Key help message.")
  367. (defvar *hkey-wconfig* nil
  368.   "Screen configuration prior to display of a help buffer.")
  369.  
  370. ;;; ************************************************************************
  371. ;;; public support functions
  372. ;;; ************************************************************************
  373.  
  374. ;; "hsite.el" contains documentation for this variable.
  375. (or (boundp 'smart-scroll-proportional) (setq smart-scroll-proportional nil))
  376.  
  377. ;; The smart keys scroll buffers when pressed at the ends of lines.
  378. ;; These next two functions do the scrolling and keep point at the end
  379. ;; of line to simplify repeated scrolls when using keyboard smart keys.
  380. ;;
  381. ;; These functions may also be used to test whether the scroll action would
  382. ;; be successful, no action is taken if it would fail (because the beginning
  383. ;; or end of a buffer is already showing) and nil is returned.
  384. ;; t is returned whenever scrolling is performed.
  385.  
  386. (defun scroll-down-eol ()
  387.   "Scrolls down according to value of smart-scroll-proportional.
  388. If smart-scroll-proportional is nil (the default) or if
  389. point is on the bottom window line, scrolls down (backward) a windowful.
  390. Otherwise, tries to bring current line to bottom of window.
  391. Leaves point at end of line and returns t if scrolled, nil if not."
  392.   (interactive)
  393.   (let ((rtn t))
  394.     (if smart-scroll-proportional
  395.     ;; If selected line is already last in window, then scroll backward
  396.     ;; a windowful, otherwise make it last in window.
  397.     (if (>= (point) (save-excursion
  398.               (goto-char (1- (window-end)))
  399.               (beginning-of-line) (point)))
  400.         (if (pos-visible-in-window-p (point-min))
  401.         (setq rtn nil)
  402.           (scroll-down))
  403.       (recenter -1))
  404.       (if (pos-visible-in-window-p (point-min))
  405.       (setq rtn nil)
  406.     (scroll-down)))
  407.     (end-of-line)
  408.     (or rtn (progn (beep) (message "Beginning of buffer")))
  409.     rtn))
  410.  
  411. (defun scroll-up-eol ()
  412.   "Scrolls up according to value of smart-scroll-proportional.
  413. If smart-scroll-proportional is nil (the default) or if
  414. point is on the top window line, scrolls up (forward) a windowful.
  415. Otherwise, tries to bring current line to top of window.
  416. Leaves point at end of line and returns t if scrolled, nil if not."
  417.   (interactive)
  418.   (let ((rtn t))
  419.     (if smart-scroll-proportional
  420.     ;; If selected line is already first in window, then scroll forward a
  421.     ;; windowful, otherwise make it first in window.
  422.     (if (<= (point) (save-excursion
  423.               (goto-char (window-start))
  424.               (end-of-line) (point)))
  425.         (if (pos-visible-in-window-p (point-max))
  426.         (setq rtn nil)
  427.           (scroll-up))
  428.       (recenter 0))
  429.       (if (pos-visible-in-window-p (point-max))
  430.       (setq rtn nil)
  431.     (scroll-up)))
  432.     (end-of-line)
  433.     (or rtn (progn (beep) (message "End of buffer")))
  434.     rtn))
  435.  
  436. (provide 'hmouse-drv)
  437.